home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / mitscheme.init < prev    next >
Encoding:
Text File  |  1995-01-04  |  7.5 KB  |  255 lines
  1. ;;;"mitscheme.init" Initialization for SLIB for MITScheme        -*-scheme-*-
  2. ;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Make this part of your ~/.scheme.init file.
  21.  
  22. ;;; (software-type) should be set to the generic operating system type.
  23. (define (software-type) 'UNIX)
  24.  
  25. ;;; (scheme-implementation-type) should return the name of the scheme
  26. ;;; implementation loading this file.
  27.  
  28. (define (scheme-implementation-type) 'MITScheme)
  29.  
  30. ;;; (scheme-implementation-version) should return a string describing
  31. ;;; the version the scheme implementation loading this file.
  32.  
  33. (define (scheme-implementation-version) "7.3.0")
  34.  
  35. ;;; *features* should be set to a list of symbols describing features
  36. ;;; of this implementation.  See Template.scm for the list of feature
  37. ;;; names.
  38.  
  39. ;the following may not be the Right Thing for this application, since
  40. ;it causes an error (rather than just returning nil) when the environment
  41. ;variable is not defined.
  42. (define getenv get-environment-variable)
  43.  
  44. ;;; (implementation-vicinity) should be defined to be the pathname of
  45. ;;; the directory where any auxillary files to your Scheme
  46. ;;; implementation reside.
  47.  
  48. (define (implementation-vicinity)
  49.   (case (software-type)
  50.     ((UNIX)     "/usr/local/src/scheme/")
  51.     ((VMS)    "scheme$src:")))
  52.  
  53. ;;; (library-vicinity) should be defined to be the pathname of the
  54. ;;; directory where files of Scheme library functions reside.
  55.  
  56. (define library-vicinity
  57.   (let ((library-path
  58.      (or (getenv "SCHEME_LIBRARY_PATH")
  59.          ;; Use this path if your scheme does not support GETENV.
  60.          (case (software-type)
  61.            ((UNIX) "/usr/local/lib/slib/")
  62.            ((VMS) "lib$scheme:")
  63.            ((MS-DOS) "C:\\SLIB\\")
  64.            (else "")))))
  65.     (lambda () library-path)))
  66.  
  67. (define *features*
  68.       '(
  69.     source                ;can load scheme source files
  70.                     ;(slib:load-source "filename")
  71.     compiled            ;can load compiled files
  72.                     ;(slib:load-compiled "filename")
  73.     rev4-report
  74.     ieee-p1178
  75.     sicp
  76.     rev4-optional-procedures
  77.     rev3-procedures
  78.     rev2-procedures
  79.     multiarg/and-
  80.     multiarg-apply
  81.     rationalize
  82.     object-hash
  83.     delay
  84.     with-file
  85.     string-port
  86.     transcript
  87.     char-ready?
  88.     record
  89.     values
  90.     dynamic-wind
  91.     ieee-floating-point
  92.     full-continuation
  93. ;    sort
  94.     queue
  95.     pretty-print
  96.     object->string
  97.     trace                ;has macros: TRACE and UNTRACE
  98.     compiler
  99.     getenv
  100.     Xwindows
  101.     ))
  102.  
  103. ;;; (OUTPUT-PORT-WIDTH <port>)
  104. (define output-port-width output-port/x-size)
  105.  
  106. ;;; (OUTPUT-PORT-HEIGHT <port>)
  107. (define (output-port-height . arg) 24)
  108.  
  109. ;;; (CURRENT-ERROR-PORT)
  110. (define current-error-port
  111.   (let ((port console-output-port))
  112.     (lambda () port)))
  113.  
  114. ;;; (TMPNAM) makes a temporary file name.
  115. (define tmpnam
  116.   (let ((cntr 100))
  117.     (lambda () (set! cntr (+ 1 cntr))
  118.         (let ((tmp (string-append "slib_" (number->string cntr))))
  119.           (if (file-exists? tmp) (tmpnam) tmp)))))
  120.  
  121. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port.
  122. (define force-output flush-output)
  123. ;;; MITScheme 7.2 is missing flush-output.  Use this instead
  124. ;(define (force-output . arg) #t)
  125.  
  126. ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
  127. ;;; port versions of CALL-WITH-*PUT-FILE.
  128. (define (call-with-output-string proc)
  129.   (let ((co (current-output-port)))
  130.     (with-output-to-string
  131.       (lambda ()
  132.     (let ((port (current-output-port)))
  133.       (with-output-to-port co
  134.         (lambda () (proc port))))))))
  135.  
  136. (define (call-with-input-string string proc)
  137.   (let ((ci (current-input-port)))
  138.     (with-input-from-string string
  139.       (lambda ()
  140.     (let ((port (current-input-port)))
  141.       (with-input-from-port ci
  142.         (lambda () (proc port))))))))
  143.  
  144. (define object->string write-to-string)
  145.  
  146. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  147. ;;; be returned by CHAR->INTEGER.  It is defined by MITScheme.
  148.  
  149. ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
  150. (define most-positive-fixnum #x03FFFFFF)
  151.  
  152. ;;; Return argument
  153. (define (identity x) x)
  154.  
  155. ;;; If your implementation provides eval, SLIB:EVAL is single argument
  156. ;;; eval using the top-level (user) environment.
  157. ;(define (slib:eval form) (eval form (repl/environment (nearest-repl))))
  158. (define (slib:eval form) (eval form user-initial-environment))
  159.  
  160. (define *macros* '(defmacro))
  161. (define (defmacro? m) (and (memq m *macros*) #t))
  162.  
  163. (syntax-table-define system-global-syntax-table 'defmacro
  164.   (macro defmacargs
  165.     (let ((macname (car defmacargs)) (macargs (cadr defmacargs))
  166.                      (macbdy (cddr defmacargs)))
  167.       `(begin
  168.      (set! *macros* (cons ',macname *macros*))
  169.      (syntax-table-define system-global-syntax-table ',macname
  170.        (macro ,macargs ,@macbdy))))))
  171.  
  172. (define (macroexpand-1 e)
  173.   (if (pair? e) (let ((a (car e)))
  174.           (if (and (symbol? a) (defmacro? a))
  175.               (apply (syntax-table-ref system-global-syntax-table a)
  176.                  (cdr e))
  177.               e))
  178.       e))
  179.  
  180. (define (macroexpand e)
  181.   (if (pair? e) (let ((a (car e)))
  182.           (if (and (symbol? a) (defmacro? a))
  183.               (macroexpand
  184.                (apply (syntax-table-ref system-global-syntax-table a)
  185.                   (cdr e)))
  186.               e))
  187.       e))
  188.  
  189. (define gentemp
  190.   (let ((*gensym-counter* -1))
  191.     (lambda ()
  192.       (set! *gensym-counter* (+ *gensym-counter* 1))
  193.       (string->symbol
  194.        (string-append "slib:G" (number->string *gensym-counter*))))))
  195.  
  196. (define defmacro:eval slib:eval)
  197. (define defmacro:load load)
  198. ;;; If your implementation provides R4RS macros:
  199. ;(define macro:eval slib:eval)
  200. ;(define macro:load load)
  201.  
  202. (define (slib:eval-load <pathname> evl)
  203.   (if (not (file-exists? <pathname>))
  204.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  205.   (call-with-input-file <pathname>
  206.     (lambda (port)
  207.       (let ((old-load-pathname *load-pathname*))
  208.     (set! *load-pathname* <pathname>)
  209.     (do ((o (read port) (read port)))
  210.         ((eof-object? o))
  211.       (evl o))
  212.     (set! *load-pathname* old-load-pathname)))))
  213.  
  214. (define record-modifier record-updater)    ;some versions need this?
  215.  
  216. ;; define an error procedure for the library
  217. (define (slib:error . args)
  218.   (apply error-procedure (append args (list (the-environment)))))
  219.  
  220. ;; define these as appropriate for your system.
  221. (define slib:tab (integer->char 9))
  222. (define slib:form-feed (integer->char 12))
  223.  
  224. (define in-vicinity string-append)
  225.  
  226. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  227. ;;; return if exitting not supported.
  228. (define slib:exit
  229.   (lambda args
  230.     (cond ((null? args) (exit))
  231.       ((eqv? #t (car args)) (exit))
  232.       ((and (number? (car args)) (integer? (car args))) (exit (car args)))
  233.       (else (exit 1)))))
  234.  
  235. ;;; Here for backward compatability
  236.  
  237. (define (scheme-file-suffix) "")
  238.  
  239. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  240. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  241.  
  242. (define slib:load-source load)
  243.  
  244. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  245. ;;; by compiling "foo.scm" if this implementation can compile files.
  246. ;;; See feature 'COMPILED.
  247.  
  248. (define slib:load-compiled load)
  249.  
  250. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  251.  
  252. (define slib:load slib:load-source)
  253.  
  254. (slib:load (in-vicinity (library-vicinity) "require"))
  255.